home *** CD-ROM | disk | FTP | other *** search
/ Delphi Programmer's Power Pack / Delphi Volume 1.iso / s_to_z / subdatab / d1unit1.pas < prev    next >
Pascal/Delphi Source File  |  1996-09-15  |  6KB  |  277 lines
  1. {$M 16384,8192}
  2. unit D1unit1;
  3.  
  4. interface
  5.  
  6. uses
  7.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  8.   Forms, Dialogs, ExtCtrls, StdCtrls, Buttons, Subdatab,
  9.  
  10.   demostat;
  11.  
  12. type
  13.   TForm1 = class(TForm)
  14.     Button1: TButton;
  15.     Button2: TButton;
  16.     OpenDialog1: TOpenDialog;
  17.     Panel1: TPanel;
  18.     Panel2: TPanel;
  19.     Panel3: TPanel;
  20.     Image1: TImage;
  21.     Panel4: TPanel;
  22.     BitBtn1: TBitBtn;
  23.     Button6: TButton;
  24.     Button7: TButton;
  25.     ButtonStatus: TButton;
  26.     ButtonReorg: TButton;
  27.     SUBDataBase1: TSUBDataBase;
  28.     procedure ButtonaddClick(Sender: TObject);
  29.     procedure FormCreate(Sender: TObject);
  30.     procedure FormDestroy(Sender: TObject);
  31.     procedure BitBtn1Click(Sender: TObject);
  32.     procedure ButtonStatusClick(Sender: TObject);
  33.     procedure ButtondeleteClick(Sender: TObject);
  34.     procedure SUBDataBase1Create(Sender: TObject);
  35.     procedure Button_downClick(Sender: TObject);
  36.     procedure Button_upClick(Sender: TObject);
  37.     procedure ButtonReorgClick(Sender: TObject);
  38.     procedure SUBDataBase1Reorg(Sender: TObject; ReorgAct: Longint);
  39.   private
  40.     { Private-Deklarationen }
  41.     searchstring : String;
  42.     procedure  GetDataRec;
  43.   public
  44.     { Public-Deklarationen }
  45.   end;
  46.  
  47. var
  48.   Form1: TForm1;
  49.  
  50. implementation
  51.  
  52. {$R *.DFM}
  53.  
  54.  
  55. Type TIcoRecord = Record
  56.        FName : String;
  57.        FId   : Longint;
  58.        FExt  : TExtension;
  59.      end;
  60.  
  61. Const   Index_Filename  = 'FileName';
  62.  
  63.  
  64. Function GetExtension ( Filename : String ) : TExtension;
  65.   var Ext: TExtension;
  66.       L: Integer;
  67. begin
  68.   L := Length(Filename);
  69.   while (L > 0) and (Filename[L] <> '.') do Dec(L);
  70.   Ext := '';
  71.   if (Filename[L] = '.') and (Length(Filename) - L <= 3) then
  72.     Ext := UpperCase(Copy(Filename, L + 1, 3));
  73.   GetExtension := Ext;
  74. end;
  75.  
  76.  
  77.  
  78.  
  79. procedure TForm1.ButtonaddClick(Sender: TObject);
  80.  
  81.   var FN : String;
  82.   var Stream : TMemoryStream;
  83.   var BitMap : TBitMap;
  84.       ICon   : TIcon;
  85.  
  86.       FIcoRecord : TIcoRecord;
  87.  
  88.       i : longint;
  89.  
  90. begin
  91.  
  92.   if OpenDialog1.Execute then  begin
  93.  
  94.     Try
  95.       for i := 1 to OpenDialog1.Files.count do begin
  96.         FN := uppercase(OpenDialog1.Files[pred(i)]);
  97.  
  98.         With FIcoRecord do begin
  99.           FName := extractfilename(FN);
  100.           FExt  := GetExtension(FName);
  101.         end;
  102.  
  103.         Image1.Picture.LoadFromFile(FN);
  104.  
  105.         Stream := TMemoryStream.Create;
  106.  
  107.         With FIcoRecord do begin
  108.           if FExt = 'BMP'
  109.           then Image1.Picture.Bitmap.SaveToStream(Stream)
  110.           else Image1.Picture.ICon.SaveToStream(Stream);
  111.         end;
  112.  
  113.  
  114.         {insert  the image}
  115.         if not SUBDataBase1.addStream ( FIcoRecord.Fid , Stream  ) then begin
  116.           Showmessage(' Daten nicht geschrieben! ');
  117.           Exit;
  118.         end;
  119.  
  120.         Stream.Free;
  121.  
  122.         searchstring  := lowercase( FIcoRecord.FName );
  123.  
  124.         {insert the Filename-Entry}
  125.         Try
  126.           SUBDataBase1.addData_Indexe ([Index_FileName],
  127.                                        [searchstring],
  128.                                        Sizeof(FIcoRecord),
  129.                                        FIcoRecord);
  130.         except
  131.           {duplicate index, file exist in Database
  132.            delete the image}
  133.           SUBDataBase1.DeleteDataWithID  ( FIcoRecord.Fid );
  134.           raise;
  135.         end;
  136.  
  137.       end;
  138.     finally
  139.       getdatarec;
  140.     end;
  141.   end;
  142. end;
  143.  
  144. {----------------------------------------------------------------}
  145.  
  146. procedure  TForm1.GetDataRec;
  147.   var Stream : TMemoryStream;
  148.       FIcoRecord : TIcoRecord;
  149. begin
  150.  
  151.   if SUBDataBase1.DatenID = -1 then begin
  152.     exit;
  153.   end;
  154.   SUBDataBase1.ReadActData (   Sizeof(FIcoRecord),
  155.                      FIcoRecord);
  156.  
  157.  
  158.   Stream := TMemoryStream.Create;
  159.   if not SUBDataBase1.ReadStream ( FIcoRecord.Fid, Stream  ) then begin
  160.     showmessage(' Daten nicht gelesen ');
  161.   end;
  162.  
  163.   Stream.Position := 0;
  164.   With FIcoRecord do begin
  165.     if FExt = 'BMP'
  166.     then Image1.Picture.BitMap.LoadFromStream(Stream)
  167.     else  Image1.Picture.ICon.LoadFromStream(Stream);
  168.   end;
  169.  
  170.   Stream.Free;
  171.  
  172.   panel1.caption := 'Records:'+inttostr(SUBDataBase1.CountKeys(Index_Filename ));
  173.   panel2.caption := FIcoRecord.FName;
  174.  
  175. end;
  176.  
  177.  
  178.  
  179. procedure TForm1.FormCreate(Sender: TObject);
  180. begin
  181.   SUBDataBase1.open;
  182.  
  183.   searchstring  := '';
  184.  
  185.   {get first record}
  186.   Button_downClick(NIL);
  187.  
  188. end;
  189.  
  190. procedure TForm1.FormDestroy(Sender: TObject);
  191. begin
  192.   SUBDataBase1.Close;
  193. end;
  194.  
  195. procedure TForm1.BitBtn1Click(Sender: TObject);
  196. begin
  197.   close;
  198. end;
  199.  
  200. procedure TForm1.ButtonStatusClick(Sender: TObject);
  201.   Var SL : Tstringlist;
  202.       F  : TStatusDialog;
  203. begin
  204.   SL := Tstringlist.create;
  205.   SUBDataBase1.GetStatistik (SL);
  206.   F  := TStatusDialog.create(NIL);
  207.   Try
  208.     f.memo1.lines := SL;
  209.     f.showmodal;
  210.   finally
  211.     f.free;
  212.     SL.free;
  213.   end;
  214. end;
  215.  
  216. procedure TForm1.ButtondeleteClick(Sender: TObject);
  217.  
  218.   var FIcoRecord : TIcoRecord;
  219.  
  220. begin
  221. {-}
  222.  
  223.   if SUBDataBase1.DatenID = -1 then begin
  224.     exit;
  225.   end;
  226.  
  227.   SUBDataBase1.ReadActData (   Sizeof(FIcoRecord),
  228.                      FIcoRecord);
  229.  
  230.   {delete the image}
  231.   SUBDataBase1.DeleteDataWithID  ( FIcoRecord.Fid );
  232.  
  233.   {delete the Filename-Entry}
  234.   SUBDataBase1.DeleteDataWithIndex( Index_Filename,lowercase(FIcoRecord.FName ));
  235.   Button_downClick(NIL);
  236.   if SUBDataBase1.DatenID = -1 then begin
  237.     Button_upClick(NIL);
  238.   end;
  239.  
  240. end;
  241.  
  242. procedure TForm1.SUBDataBase1Create(Sender: TObject);
  243. begin
  244.   SUBDataBase1.createIndex (Index_Filename , 60, false);
  245.                                              {indexlength, duplicate}
  246. end;
  247.  
  248. procedure TForm1.Button_downClick(Sender: TObject);
  249. begin
  250.   searchstring  := SUBDataBase1.NextIndex (Index_filename,searchstring);
  251.   getdatarec;
  252. end;
  253.  
  254. procedure TForm1.Button_upClick(Sender: TObject);
  255. begin
  256.   searchstring  := SUBDataBase1.PrevIndex (Index_filename,searchstring);
  257.   getdatarec;
  258. end;
  259.  
  260.  
  261. procedure TForm1.ButtonReorgClick(Sender: TObject);
  262. begin
  263.   Subdatabase1.Reorganisation;
  264. end;
  265.  
  266. procedure TForm1.SUBDataBase1Reorg(Sender: TObject; ReorgAct: Longint);
  267. begin
  268.  
  269.   panel1.caption := 'reorg: '+inttostr(ReorgAct)+' until: '+
  270.     inttostr(SUBDataBase1.Reorgmax);
  271.  
  272.   Application.processmessages;
  273.  
  274. end;
  275.  
  276. end.
  277.